home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / gsdbloo.exe / GS_DATE.PAS < prev    next >
Pascal/Delphi Source File  |  1992-02-24  |  8KB  |  305 lines
  1. unit GS_Date;
  2. {-----------------------------------------------------------------------------
  3.                              Date Processor
  4.  
  5.        GS_DATE Copyright (c)  Richard F. Griffin
  6.  
  7.        02 May 1991
  8.  
  9.        102 Molded Stone Pl
  10.        Warner Robins, GA  31088
  11.  
  12.        -------------------------------------------------------------
  13.        This unit handles date conversion.
  14.  
  15.                    SHAREWARE  -- COMMERCIAL USE RESTRICTED
  16.  
  17.  
  18.  
  19.        Changes:
  20.  
  21.        03 May 91 - Added GS_Date_Century flag.  When true, the GS_Date_View
  22.                    function will return MM/DD/YYYY.  When false, only the last
  23.                    two digits of the year will be returned (MM/DD/YY).  The
  24.                    default is false.
  25.  
  26.        Acknowledgements:
  27.  
  28.        An astronomers' Julian day number is a calendar system which is useful
  29.        over a very large span of time.  (January 1, 1988 A.D. is 2,447,162 in
  30.        this system.)  The mathematics of these procedures originally restricted
  31.        the valid range to March 1, 0000 through February 28, 4000.  The update
  32.        by Carley Phillips changes the valid end date to December 31, 65535.
  33.  
  34.        The basic algorithms are based on those contained in the COLLECTED
  35.        ALGORITHMS from Communications of the ACM, algorithm number 199,
  36.        originally submitted by Robert G. Tantzen in the August, 1963 issue
  37.        (Volume 6, Number 8).  Note that these algorithms do not take into
  38.        account that years divisible by 4000 are NOT leap years.  Therefore the
  39.        calculations are only valid until 02-28-4000.  These procedures were
  40.        modified by Carley Phillips (76630,3312) to provide a mathematically
  41.        valid range of 03-01-0000 through 12-31-65535.
  42.  
  43.        The main part of Tantzen's original algorithm depends on treating
  44.        January and February as the last months of the preceding year.  Then,
  45.        one can look at a series of four years (for example, 3-1-84 through
  46.        2-29-88) in which the last day will be either the 1460th or the 1461st
  47.        day depending on whether the 4-year series ended in a leap day.
  48.  
  49.        By assigning a longint julian date, computing differences between
  50.        dates, adding days to an existing date, and other mathematical actions
  51.        become much easier.
  52.  
  53. ------------------------------------------------------------------------------}
  54.  
  55. interface
  56. {$D-}
  57. uses
  58.     Dos;
  59.  
  60. const
  61.    GS_Date_JulInv  =  -1;             {constant for invalid Julian day}
  62.  
  63. type
  64.    GS_Date_StrTyp  = string[10];
  65.    GS_Date_ValTyp  = longint;
  66.  
  67. var
  68.    GS_Date_Century : boolean;
  69.  
  70.  
  71. function  GS_Date_Curr : GS_Date_ValTyp;
  72. function  GS_Date_DBStor(nv : GS_Date_ValTyp) : GS_Date_StrTyp;
  73. function  GS_Date_View(nv : GS_Date_ValTyp) : GS_Date_StrTyp;
  74. function  GS_Date_Juln(sdate : GS_Date_StrTyp) : GS_Date_ValTyp;
  75. function  GS_Date_MDY2Jul(month, day, year : word) : GS_Date_ValTyp;
  76. procedure GS_Date_Jul2MDY(jul : GS_Date_ValTyp; var month, day, year  : word);
  77.  
  78.  
  79. implementation
  80.  
  81. const
  82.    JulianConstant =  1721119;  {constant for Julian day for 02-28-0000}
  83.    JulianMin      =  1721120;  {constant for Julian day for 03-01-0000}
  84.    JulianMax      =  25657575; {constant for Julian day for 12-31-65535}
  85.  
  86. function LeapYearTrue (year : word)  : boolean;
  87. begin
  88.    LeapYearTrue := false;
  89.    if (year mod 4 = 0) then
  90.       if (year mod 100 <> 0) or (year mod 400 = 0) then
  91.          if (year mod 4000 <> 0) then
  92.             LeapYearTrue :=  true;
  93. end;
  94.  
  95. function DateOk (month, day, year  : word) : boolean;
  96. var
  97.    daz : integer;
  98. begin
  99.    if (day <> 0) and
  100.       ((month > 0) and (month < 13)) and
  101.       ((year <> 0) or (month > 2)) then
  102.    begin
  103.       case month of
  104.          2  : begin
  105.                  daz := 28;
  106.                  if (LeapYearTrue(year)) then inc(daz);
  107.               end;
  108.          4,
  109.          6,
  110.          9,
  111.          11 : daz := 30;
  112.          else  daz := 31;
  113.       end;
  114.       DateOk := day <= daz;
  115.    end
  116.    else DateOk := false;
  117. end;
  118.  
  119. function GS_Date_MDY2Jul(month, day, year : word) : GS_Date_ValTyp;
  120. var
  121.    wmm,
  122.    wyy,
  123.    jul  : longint;
  124. begin
  125.    wyy := year;
  126.    if (month > 2) then wmm  := month - 3
  127.       else
  128.       begin
  129.          wmm := month + 9;
  130.          dec(wyy);
  131.       end;
  132.    jul := (wyy div 4000) * 1460969;
  133.    wyy := (wyy mod 4000);
  134.    jul := jul +
  135.             (((wyy div 100) * 146097) div 4) +
  136.             (((wyy mod 100) * 1461) div 4) +
  137.             (((153 * wmm) + 2) div 5) +
  138.             day +
  139.             JulianConstant;
  140.    if (jul < JulianMin) or (JulianMax < jul) then
  141.       jul := GS_Date_JulInv;
  142.    GS_Date_MDY2Jul := jul;
  143. end;
  144.  
  145. procedure GS_Date_Jul2MDY(jul : GS_Date_ValTyp; var month, day, year  : word);
  146. var
  147.    tmp1 : longint;
  148.    tmp2 : longint;
  149. begin
  150.    if (JulianMin <= jul) and (jul <= JulianMax) then
  151.       begin
  152.          tmp1  := jul - JulianConstant; {will be at least 1}
  153.          year  := ((tmp1-1) div 1460969) * 4000;
  154.          tmp1  := ((tmp1-1) mod 1460969) + 1;
  155.          tmp1  := (4 * tmp1) - 1;
  156.          tmp2  := (4 * ((tmp1 mod 146097) div 4)) + 3;
  157.          year  := (100 * (tmp1 div 146097)) + (tmp2 div 1461) + year;
  158.          tmp1  := (5 * (((tmp2 mod 1461) + 4) div 4)) - 3;
  159.          month :=   tmp1 div 153;
  160.          day   := ((tmp1 mod 153) + 5) div 5;
  161.          if (month < 10) then
  162.             month  := month + 3
  163.          else
  164.             begin
  165.                month  := month - 9;
  166.                year := year + 1;
  167.             end {else}
  168.       end {if}
  169.    else
  170.       begin
  171.          month := 0;
  172.          day   := 0;
  173.          year  := 0;
  174.       end; {else}
  175. end;
  176.  
  177.  
  178. function GS_Date_Curr : GS_Date_ValTyp;
  179. Var
  180.   month, day, year : word;
  181.   cw : word;
  182. begin
  183.    GetDate(year,month,day,cw);
  184.    GS_Date_Curr := GS_Date_MDY2Jul(month, day, year);
  185. end;
  186.  
  187. function GS_Date_DBStor(nv : GS_Date_ValTyp) : GS_Date_StrTyp;
  188. var
  189.    mm,
  190.    dd,
  191.    yy  : word;
  192.    ss  : string[8];
  193.    sg  : string[4];
  194.    i   : integer;
  195. begin
  196.    ss := '        ';
  197.    if nv > GS_Date_JulInv then
  198.    begin
  199.       GS_Date_Jul2MDY(nv,mm,dd,yy);
  200.       str(mm:2,sg);
  201.       move(sg[1],ss[5],2);
  202.       str(dd:2,sg);
  203.       move(sg[1],ss[7],2);
  204.       str(yy:4,sg);
  205.       move(sg[1],ss[1],4);
  206.       for i := 1 to 8 do if ss[i] = ' ' then ss[i] := '0';
  207.    end;
  208.    GS_Date_DBStor := ss;
  209. end;
  210.  
  211. function GS_Date_View(nv : GS_Date_ValTyp) : GS_Date_StrTyp;
  212. var
  213.    mm,
  214.    dd,
  215.    yy  : word;
  216.    ss  : string[10];
  217.    sg  : string[4];
  218.    i   : integer;
  219. begin
  220.    ss := '  /  /    ';
  221.    if nv > GS_Date_JulInv then
  222.    begin
  223.       GS_Date_Jul2MDY(nv,mm,dd,yy);
  224.       str(mm:2,sg);
  225.       move(sg[1],ss[1],2);
  226.       str(dd:2,sg);
  227.       move(sg[1],ss[4],2);
  228.       str(yy:4,sg);
  229.       if GS_Date_Century then
  230.       begin
  231.           move(sg[1],ss[7],4);
  232.           ss[0] := #10;
  233.       end
  234.       else
  235.       begin
  236.          move(sg[3],ss[7],2);
  237.          ss[0] := #8;
  238.       end;
  239.       for i := 1 to length(ss) do if ss[i] = ' ' then ss[i] := '0';
  240.    end
  241.    else
  242.    begin
  243.       if GS_Date_Century then ss[0] := #10 else ss[0] := #8;
  244.    end;
  245.    GS_Date_View := ss;
  246. end;
  247.  
  248. function GS_Date_Juln(sdate : GS_Date_StrTyp) : GS_Date_ValTyp;
  249. var
  250.    t      : string[10];
  251.    valu,
  252.    yy,
  253.    mm,
  254.    dd     : string[4];
  255.    mmn,
  256.    ddn,
  257.    yyn    : word;
  258.    rsl    : integer;
  259.    cc     : char;
  260.    okDate : boolean;
  261.    co     : longint;
  262. begin
  263.    t := sdate;
  264.    cc := t[3];
  265.    if cc in ['0'..'9'] then
  266.    begin
  267.       mm := copy(t,5,2);
  268.       dd := copy(t,7,2);
  269.       yy := copy(t,1,4);
  270.    end
  271.    else
  272.    begin
  273.       mm := copy(t,1,2);
  274.       dd := copy(t,4,2);
  275.       yy := copy(t,7,4);
  276.       if length(yy) = 2 then yy := '19'+yy;
  277.    end;
  278.    okDate := false;
  279.    val(mm,mmn,rsl);
  280.    if rsl = 0 then
  281.    begin
  282.       val(dd,ddn,rsl);
  283.       if rsl = 0 then
  284.       begin
  285.          val(yy,yyn,rsl);
  286.          if rsl = 0 then
  287.          begin
  288.             if DateOk(mmn,ddn,yyn) then okDate := true;
  289.          end;
  290.       end;
  291.    end;
  292.    if not okDate then
  293.       co := GS_Date_JulInv
  294.    else
  295.    begin
  296.       co := GS_Date_MDY2Jul(mmn, ddn, yyn);
  297.    end;